[VBA] Userform: MonthView control - select dates not next to each other?

[eljaystang]

Using the MonthView calendar control in a userform, is there any way to allow the user to make noncontiguous date selections (within the same month, of course)? I can't find a way. The MultiSelect property only allows date extensions (contiguous selection).

I would like a calendar control on a userform that allows noncontiguous date selections if there's another such control. (Cannot use add-ins, though.)

Thanks.

 

[AddinBox_Tsunoda]

Hi, eljaystang.

It is a sample expressing the date when you clicked it in a bold-face.
A bold-face is reset if you click the same date again.

You can appoint plural dates of the discontinuity.
The bold-faced state is maintained even if you change the month.
You can get the bold-faced state of the date by [ BoldStates ] property.
All bold-faces are removed by [ Reset ] method.


Please place [ MonthView1 , CommandButton1 , CommandButton2 , ListBox1 ] in UserForm.

--- UserForm module ---

Private WithEvents BoldMonthView As clsBoldMonthView

Private Sub UserForm_Initialize()
    Set BoldMonthView = New clsBoldMonthView
    Set BoldMonthView.MonthView = MonthView1
End Sub

Private Sub UserForm_Terminate()
    Set BoldMonthView = Nothing
End Sub

Private Sub BoldMonthView_DateClick(ByVal DateClicked As Date, ByVal BoldState As Boolean)
'    MsgBox DateClicked & " ( " & BoldState & " )"
End Sub

Private Sub CommandButton1_Click()
Dim Temp As Collection
Dim i As Integer
    ListBox1.Clear
    Set Temp = BoldMonthView.BoldStaes
    If (Temp.Count > 0) Then
        For i = 1 To Temp.Count
            ListBox1.AddItem Format(Temp.Item(i), "yyyy/mm/dd")
        Next i
    End If
End Sub

Private Sub CommandButton2_Click()
    BoldMonthView.Reset
    ListBox1.Clear
End Sub

Please insert a class module and change the class name from "Class1" to "clsBoldMonthView".
--- Class module ( clsBoldMonthView ) ---

Public Event DateClick(ByVal DateClicked As Date, ByVal BoldState As Boolean)
Private WithEvents MyMonthView As MonthView

Private colBoldDate As Collection   'Bold-faced days collection

Private Sub Class_Initialize()
    Set colBoldDate = New Collection
End Sub

Private Sub Class_Terminate()
    Set colBoldDate = Nothing
    Set MyMonthView = Nothing
End Sub

Public Property Set MonthView(ByVal Target As MonthView)
    Set MyMonthView = Target
End Property

Public Property Get BoldStaes() As Collection
Dim temp As Collection
Dim DateArray() As Date
Dim i As Integer
    Set temp = New Collection
    If (colBoldDate.Count > 0) Then
        DateArray = CollectionDateSort
        For i = 1 To UBound(DateArray)
            temp.Add DateArray(i)
        Next i
    End If
    Set BoldStaes = temp
End Property

Public Sub Reset()
    Set colBoldDate = New Collection
    Call SetDayBold
End Sub

Private Sub MyMonthView_Click()
    'Bold-faced setting with the change of the month
    Call SetDayBold
End Sub

Private Sub MyMonthView_DateClick(ByVal DateClicked As Date)
Dim Bold_State As Boolean
    With MyMonthView
        'Check whether the day is set to a bold-face
        If (ChkDayCol(DateClicked) = False) Then
            'Set Bold-face
            colBoldDate.Add Item:=DateClicked, _
                            Key:=Format(DateClicked, "yyyy/mm/dd")
            .DayBold(DateClicked) = True
            Bold_State = True
        Else
            'Reset Bold-face
            colBoldDate.Remove Index:=Format(DateClicked, "yyyy/mm/dd")
            .DayBold(DateClicked) = False
            Bold_State = False
        End If
    End With
    
    'For the case that clicked a part of the last month or the next month.
    Call SetDayBold
    
    RaiseEvent DateClick(DateClicked, Bold_State)
End Sub

'Set a registration date to a bold-face
Private Sub SetDayBold()
Dim i As Integer
Dim temp As Date
    With MyMonthView
        If (colBoldDate.Count = 0) Then
            For temp = .VisibleDays(1) To .VisibleDays(42)
                .DayBold(temp) = False    'for [Reset] method
            Next temp
        Else
            For i = 1 To colBoldDate.Count
                If (colBoldDate(i) >= .VisibleDays(1)) And _
                   (colBoldDate(i) <= .VisibleDays(42)) Then
                    .DayBold(colBoldDate(i)) = True
                End If
            Next i
        End If
    End With
End Sub

'Check having bold-faced setting or not
Private Function ChkDayCol(ByVal ChkDate As Date) As Boolean
Dim dmy As Date
    On Error Resume Next
    dmy = colBoldDate.Item(Format(ChkDate, "yyyy/mm/dd"))
    If (Err.Number = 0) Then
        ChkDayCol = True
    Else
        ChkDayCol = False
    End If
    Err.Clear
End Function

Private Function CollectionDateSort() As Variant
Dim DateArray() As Date
Dim vntTemp1 As Date
Dim vntTemp2 As Date
Dim blnContinue As Boolean
Dim gap As Long
Dim i As Long

    If (colBoldDate.Count = 0) Then
        Exit Function
    End If
    
    ReDim DateArray(1 To colBoldDate.Count)
    For i = 1 To colBoldDate.Count
        DateArray(i) = colBoldDate.Item(i)
    Next i

'=== Date order sort by ComSort11 algorithm ===
    gap = colBoldDate.Count - 1
    blnContinue = True
    
    Do While (gap > 1) Or (blnContinue = True)
        gap = Int(CDbl(gap) / 1.3)
        If (gap = 9) Or (gap = 10) Then
            gap = 11
        ElseIf (gap < 1) Then
            gap = 1
        End If

        blnContinue = False
        For i = 1 To (colBoldDate.Count - gap)
            If ((DateArray(i) > DateArray(i + gap))) Then
                vntTemp1 = DateArray(i)
                vntTemp2 = DateArray(i + gap)
                DateArray(i) = vntTemp2
                DateArray(i + gap) = vntTemp1
                blnContinue = True
            End If
        Next i
    Loop
    
    CollectionDateSort = DateArray
End Function

PS:
Bold-faced indication is not reflected on a date of the first row
left edge (last month part) by malfunction of the MonthView control.

Please check it in Google for more information about ComSort11 algorithm.

 

[eljaystang]

Thanks! It works as I asked. I think I can adapt it for what I need. I just have to tear the code down to be sure I understand it. There are several things in it I need to look up. I rarely use class modules and wasn't aware of events for controls in a userform. That's great. I am familiar with arrays and collections, but I have a few things to learn from your code. May have questions. Thanks again.

 

[eljaystang]

PS:
Bold-faced indication is not reflected on a date of the first row
left edge (last month part) by malfunction of the MonthView control.

Please check it in Google for more information about ComSort11 algorithm.

AddinBox_Tsunoda, that was amazing. I tore down the code and commented it to understand it and stepped through the parts I didn't understand and now feel good about it. That was some great coding strategy!

A few questions... Where did you find this if you don't mind me asking? What is the "malfunction" you mentioned? (I didn't see an issue.) Also, I could not find anything on "ComSort11".

Thanks!

 

[AddinBox_Tsunoda]

Hi, eljaystang.

> Where did you find this.
I made it for an answer in Japanese VBA forum in March, 2005.
I made it the class newly this time to make it easy to use it more.


> What is the "malfunction" you mentioned? (I didn't see an issue.)
Please refer to the image below.

> I could not find anything on "ComSort11".
Please refer to the following site.

https://rosettacode.org/wiki/Sorting_algorithms/Comb_sort

Variants:
Combsort11 makes sure the gap ends in (11, 8, 6, 4, 3, 2, 1),
which is significantly faster than the other two possible endings.

 

[eljaystang]

Hey, I love it. That was some creative coding to get it to sort and all the other actions. The malfunction is not an issue. We are used to it "flipping over to the next month" and leaving the previous date grayed out. Not a problem there. Thanks again for reposting this for me. I'll be adapting it for what I need.